home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / IO._c < prev    next >
Text File  |  1990-12-08  |  28KB  |  1,073 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "files.h"
  22.  
  23. IMPORT void ABORT(),ARGERROR(),ERROR(),SYSTEMERROR();      /* from linebufffer.c */
  24. IMPORT boolean ground();
  25. IMPORT TERM SKELETON();
  26. IMPORT TERM A0,A1;               /* from evalpreds.c     */
  27. IMPORT int INTVALUE();           /* from arith.c         */
  28. IMPORT long lseek();             /* from clib            */
  29. IMPORT boolean LONGRES();        /* from unify.c         */
  30. IMPORT TERM READIN();            /* fom readin.c         */
  31. IMPORT void WRITEOUT(),DISPLAY(); /* from writeout.c      */
  32. IMPORT void ABORT_WRITE();
  33. IMPORT   ENV TOPENV;             /* from prolog.c        */
  34. IMPORT   boolean ECHOFLAG;
  35. IMPORT  void KILLSTACKS();      /* from unify.c */
  36. IMPORT  int ERRORFLAG;
  37. IMPORT  boolean EVENT;
  38. IMPORT  boolean SPYTRACE;
  39. IMPORT string strcpy();                 /* from CLIB            */
  40. IMPORT void destroycl();                /* from database.c      */
  41. IMPORT boolean UserAbort;
  42. IMPORT void CHECKATOM();
  43. IMPORT TERM CALLX;
  44. IMPORT ENV CALLXENV;
  45. IMPORT string s_cls(),s_gotoxy();         /* from sys.c */
  46. IMPORT boolean  xWINDOW_ON;
  47. IMPORT boolean FileExist();
  48. IMPORT boolean isatom();
  49. IMPORT TERM heapterms(),mk2sons();
  50. IMPORT ATOM copyatom();
  51. IMPORT void LONG_JMP(),ERRORJMP();
  52. IMPORT boolean INTRES();
  53. IMPORT int open(),creat(),close(),isatty(),unlink();  /* from clib */
  54. IMPORT int read(),write();
  55. IMPORT void TESTATOM();
  56. IMPORT boolean UNIFY();
  57. #if WINDOWS
  58. IMPORT char t_rc();
  59. #endif
  60.  
  61. /*
  62. EXPORT boolean DOSEE(),DOTELL(),DOSEEK();
  63. EXPORT boolean DOOPEN(),DOCLOSE();
  64. EXPORT boolean DOREAD();
  65. EXPORT boolean DOGET(),DOGET0(),DOASK();
  66. EXPORT void DOPUT(),DOTAB(),DOWRITE(),DOWRITQ();
  67. EXPORT void DONL(),DOSKIP();
  68. EXPORT void DODISLAY();
  69. EXPORT  file inputfile,outputfile
  70. EXPORT  file OpenFile(ATOM,fmode);
  71. EXPORT  void CloseFile(file);
  72. EXPORT  void FileError(ERRORNR);
  73. EXPORT  file_type file_tab[];
  74. EXPORT  boolean FERRORFLAG;
  75. #ifdef ARCHY
  76. EXPORT  boolean SYNCLFLAG;
  77. #endif
  78. EXPORT TERM phy_name();
  79. EXPORT void SYNERROR(),ABORT() , SYSTEMERROR();
  80. EXPORT void GETCHAR(),REGET();
  81. EXPORT boolean LINEENDED(),FILEENDED();
  82. EXPORT char CH,LASTCH;
  83. EXPORT int ERRPOS;
  84. EXPORT   void InitIO()
  85. EXPORT   void ws(string)         write string to outputfile
  86. EXPORT   boolean IOERRORFLAG
  87.  */
  88.  
  89. #if CPM
  90. #define isatty(f)    (!(f<0 || f>2))
  91. #endif
  92.  
  93. FORWARD void FileError();  /* forward declaration */
  94. FORWARD void InitIO();
  95.  
  96. #ifdef DYNMEM
  97. GLOBAL TERM tempterm;  /* for phy_name */
  98. #else
  99. GLOBAL TERM tempterm = nil_term;  /* for phy_name */
  100. #endif
  101.  
  102. /*********************************************************/
  103. /*                filedefinitions                        */
  104. /*********************************************************/
  105.  
  106.  
  107. GLOBAL file_type file_tab[MAXFILES];
  108. GLOBAL boolean FERRORFLAG=true;
  109. #ifdef ARCHY
  110. GLOBAL boolean SYNCLFLAG=true;
  111. #endif
  112. GLOBAL file inputfile,outputfile;
  113.  
  114. GLOBAL TERM phy_name(register ATOM A)
  115. {
  116.     int depth=0;
  117.  
  118.     register TERM F=nil_term;
  119.     register CLAUSE CL;
  120.    start:;
  121.     if(depth++ > 10)ERROR(DEPTHE);
  122.     for(CL=clause(FNAME_2);non_nil_clause(CL);CL=nextcl(CL))
  123.     {
  124.         if(var_sizes(CL) !=0) SYSTEMERROR("phys filename");
  125.         if(name(arg2(head(CL)))==A)
  126.         { F=arg1(head(CL));
  127.           if(isatom(F)){ A=name(F) ; goto start; }
  128.           return F;
  129.         }
  130.     }
  131.     name(tempterm)=A;
  132.     return tempterm;
  133. }
  134.  
  135. GLOBAL file OpenFile(register TERM filename, fmode mode)
  136. {
  137.     register file f;
  138.     deref(filename); 
  139.     if(! ground(filename,MAXDEPTH)) SYSTEMERROR("OpenFiles.0");
  140.     /* search filename in filetab */
  141.     for(f=0;f < MAXFILES;f++)
  142.     { if(FNAME(f)==nil_term || !UNI(filename,FNAME(f))) continue;
  143.       if(!xWINDOW_ON)return f;
  144. #if WINDOWS
  145.       if(FTYPE(f)==NORMFT) return f;
  146.       if(FTYPE(f)==WINDOWFT)
  147.         { if(mode !=look_mode) w_up(FWINPTR(f)); return f; }
  148.       SYSTEMERROR("OpenFiles.1");
  149. #endif
  150.     }
  151.     /* file not open */
  152.     for(f=0;f < MAXFILES ; f++)
  153.         if(FNAME(f)==nil_term) break;
  154.     if(f >=MAXFILES) return ERRFILE;
  155.     if( isatom(filename))
  156.     { string fn;
  157.         fn=tempcopy(name(filename));
  158.         /* an ordinary file */
  159.         switch(mode)
  160.         {
  161.             case look_mode: return NOFILE;
  162.             case read_mode:
  163.                      if((FINPTR(f)=open(fn,0))<0)
  164.                          return NOFILE;
  165.                      CANREAD(f)=!(CANWRITE(f)=false);
  166.                      break;
  167.             case write_mode:
  168.                      if((FOUTPTR(f)=creat(fn,0666))<0)
  169.                          return NOFILE;
  170.                      CANREAD(f)=!(CANWRITE(f)=true);
  171.                      break;
  172.             case read_write:
  173.                      if((FOUTPTR(f)=FINPTR(f)=open(fn,2))<0)
  174.                      {
  175.                          if(FileExist(fn)) return NOFILE;
  176.                          (void)close(creat(fn,0666));
  177.                          if((FINPTR(f)=FOUTPTR(f)=open(fn,2))<0)
  178.                          {
  179.                              unlink(fn);
  180.                              return NOFILE;
  181.                          }
  182.                      }
  183.                      CANREAD(f)=CANWRITE(f)=true;
  184.                      break;
  185.              default:
  186.                      SYSTEMERROR("OpenFile.2");
  187.         } /* switch */
  188.         FNAME(f)=SKELETON(NOT_1,filename); /* see SKELETON ! */
  189.         FTYPE(f)=NORMFT;
  190.         ISEOF(f)=ISINPUT(f)=false;
  191.         ISTTY(f)=isatty(f);
  192.         FLINENO(f)=0;
  193.         FCHARPOS(f)=FBUFLENGTH(f)=0;
  194.         return f;
  195.     }
  196. #if WINDOWS
  197.     else if(xWINDOW_ON && name(filename)==WINDOW_6)
  198.     {
  199.         int a,b,c,d;
  200.         static string winname;
  201.         byte
  202.         attr=0;
  203.         TERM T,TT;
  204.         if(mode==look_mode) return NOFILE;
  205.         TT=son(filename); a=INTVALUE(TT);
  206.         next_br(TT); b=INTVALUE(TT);
  207.         next_br(TT); c=INTVALUE(TT);
  208.         next_br(TT); d=INTVALUE(TT);
  209.         next_br(TT);T=TT;deref(T);
  210.         CHECKATOM(T);
  211.         winname=tempcopy(copyatom(name(T)));
  212.  
  213.         next_br(TT);
  214.         deref(TT);
  215.         while(name(TT)==CONS_2)
  216.           { T=arg1(TT);TT=arg2(TT);
  217.             switch(name(T))
  218.             { case BLINK_0:   attr |=BLINK;break;
  219.               case REVERSE_0: attr |=REVERSE;break;
  220.               case BOLD_0:    attr |=BOLD;break;
  221.               case UNDER_0:   attr |=UNDERLINE;break;
  222.             }
  223.           }
  224.         TESTATOM(NIL_0,TT);
  225.         FTYPE(f)=WINDOWFT;
  226.         if((FWINPTR(f)=w_create(a,b,c,d,winname,attr))==NOWINDOW) 
  227.             return ERRFILE;
  228.         FNAME(f)=SKELETON(NOT_1,filename);
  229.         ISEOF(f)=ISINPUT(f)=false;
  230.         ISTTY(f)=true;
  231.         CANREAD(f)=CANWRITE(f)=true;
  232.         return f;
  233.     }
  234. #endif
  235.     else return NOFILE;
  236. }
  237.  
  238.  
  239.  
  240. GLOBAL void CloseFile(register int f)
  241. {
  242.     if(f<4 || FNAME(f)==nil_term) return;
  243.     if(FTYPE(f)==NORMFT)
  244.     {
  245.         if(FINPTR(f) > 2) (void)close(FINPTR(f));
  246.         if(FOUTPTR(f) > 2) (void)close(FOUTPTR(f));
  247.     }
  248. #if WINDOWS
  249.     else if(xWINDOW_ON && FTYPE(f)==WINDOWFT) w_remove(FWINPTR(f));
  250. #endif
  251.     else SYSTEMERROR("CloseFile.1");
  252.     FNAME(f)=nil_term;
  253. }
  254.  
  255. /******************************************************/
  256. /*                     basicio                        */
  257. /******************************************************/
  258.  
  259. #define MAXDIGITS 25   /* max digits for number conversation */
  260. LOCAL  char numbuffer[MAXDIGITS]; /* for number conversation */
  261.  
  262.  
  263. GLOBAL int IOERRORFLAG=0;
  264.  
  265. /* short hand notation for basic i/o in this module */
  266. #define NOTREAD  0
  267. #define NOTWRITE         1
  268. #define Errornumber      int
  269.  
  270.  
  271. LOCAL char *errmsg[]={
  272.                        "read error",/* NOTREAD */
  273.                        "write error" /* NOTWRITE */
  274.                       };
  275.  
  276. LOCAL void IO_Error(TERM f, Errornumber e)
  277. { if(IOERRORFLAG++>3) ABORT(IOERROR);
  278.   if((outputfile=OpenFile(phy_name(STDERR_0),write_mode))<0)
  279.       ABORT(IOERROR);
  280.   ws("\ni/o error in file '"); DISPLAY(f); ws("' : "); ws(errmsg[e]);
  281.   ERROR(IOERROR);
  282. }
  283.  
  284. #if REALARITH
  285.  
  286. GLOBAL char* ftoa(double d)
  287. {
  288.    register char *cp; 
  289.    register r;
  290.    register int expo ;
  291.  
  292.    cp=numbuffer;
  293.    if(d !=0.0 && d==10.0*d)
  294.    {/*overflow */ 
  295.         strcpy(numbuffer,"99e999");
  296.         return (char *)numbuffer;
  297.    }
  298.    if( d < 0.0){
  299.  *cp++= '-'; d= -d; 
  300.  }
  301.    *cp++= '0' ;
  302.    *cp++= '.';
  303.    r=0;
  304.    expo=0;
  305.    if( d==0.0  ) {
  306.  *cp++= '0';
  307.  *cp++=0; 
  308.  return (char *)numbuffer;
  309.  }
  310.    if(d >=1.0 ){
  311.  while(d >=1.0e+9){
  312.          r +=10;d *=1.0e-10;
  313.          }
  314.  while(d >=1.0 ){
  315.          r++ ; d *=1.0e-1;
  316.          }
  317.  }
  318.    else {
  319.  while(d < 1.0e-10){
  320.          r -=10; d *=1.0e+10;
  321.          }
  322.  while(d < 1.0e-1){
  323.          r-- ; d *=10.0 ; 
  324.          }
  325.  }
  326.    expo=r ;
  327. #if MAXDIGITS-9<12
  328.    r=MAXDIGITS-9;
  329. #endif
  330. #if MAXDIGITS-9>=12
  331.    r=12;
  332. #endif
  333.    while(r-- >0){
  334.          register i;
  335.          d *=1.0e+1; i= (int)d ; d -= (double)i;
  336.          *cp++= '0' + i;
  337.     }
  338.    if(*(cp-1)=='9')
  339.    {
  340.         while(*--cp=='9');
  341.         if(*cp== '.') 
  342.           { *((cp++)-1)= '1';*cp++= '0';}
  343.         else
  344.           { (*cp++)++;*cp++= '0';}
  345.    }
  346.    while(*--cp=='0');
  347.    if(*cp++== '.') *cp++= '0';
  348.    *cp++= 'e';
  349.    if(expo <0)  { *cp++= '-' ; expo= -expo;}
  350.    else *cp++= '+';
  351.    if( expo >=100 ){*cp++='0' + expo / 100 ; expo %=100 ;} 
  352.    *cp++= '0' + expo/10;
  353.    *cp++='0' + expo %10;
  354.    *cp=0;
  355.    return (char *)numbuffer;
  356. }
  357.  
  358. #endif
  359.  
  360. #if LONGARITH 
  361. GLOBAL char *ltoa(long v)
  362. {
  363.       long int r; 
  364.       register char *p; 
  365.       int sign;
  366.       if(v<0l) {sign=1; r= -v;} else {sign=0; r=v;}
  367.       p= &numbuffer[MAXDIGITS-2];
  368.       if(r==0l) *p--='0';
  369.       else do *p--=r%10l+'0'; while(r/=10l);
  370.       if(sign) *p--='-';
  371.       p++;
  372.       numbuffer[MAXDIGITS-1]=0;
  373.       return p;
  374. }
  375. #endif
  376.  
  377. GLOBAL char *itoa(int v)
  378. { int r; 
  379.   register char *p; 
  380.   int sign, h=0;
  381.       if(v==minint) {v++; h=1; }
  382.       if(v<0l) {sign=1; r= -v;} else {sign=0; r=v;}
  383.       p= &numbuffer[MAXDIGITS-2];
  384.       if(r==0l) *p--='0';
  385.       else do *p--=r%10+'0';
  386.     while(r/=10);
  387.       numbuffer[MAXDIGITS-2]+=h;
  388.       if(sign) *p--='-';
  389.       /* h= &numbuffer[MAXDIGITS-2]-p; */
  390.       p++;
  391.       numbuffer[MAXDIGITS-1]=0;
  392.       return p;
  393. }
  394.  
  395. GLOBAL void wi(int N)
  396. { ws(itoa(N)); }
  397.  
  398. GLOBAL void wc( char ch)
  399. { static char c[2];c[0]=ch;c[1]='\0';ws(c); }
  400.  
  401. GLOBAL void out_1(register char *s)
  402. {
  403.     (void)write(1,s,strlen(s));
  404. }
  405.  
  406. GLOBAL void out_2(register char *s)
  407. {
  408.     (void)write(2,s,strlen(s));
  409. }
  410.  
  411. #if !CPM
  412.  
  413. #define OBLEN 85
  414.  
  415. LOCAL char outbuffer[OBLEN];
  416. LOCAL int outbufpos=0;
  417. LOCAL boolean o_buf_flag=false;
  418.  
  419. LOCAL mws(string s)
  420. { register int i; register char *p;
  421.   for(i=0, p=s; *p; p++) i++;
  422.   if(FTYPE(outputfile)==NORMFT)
  423.   {
  424.       if(write(FOUTPTR(outputfile),s,i) !=i && !UserAbort)
  425.           IO_Error(FNAME(outputfile),NOTWRITE);
  426.   }
  427. #if WINDOWS
  428.   else if(xWINDOW_ON && FTYPE(outputfile)==WINDOWFT)
  429.       w_puts(FWINPTR(outputfile),s);
  430. #endif
  431.   else SYSTEMERROR("ws.1");
  432. }
  433.  
  434. GLOBAL void out_buffer(int mode)
  435. {
  436.     switch(mode)
  437.     {
  438.         case BUF_ON: o_buf_flag=true;break;
  439.         case BUF_OFF: o_buf_flag=false;
  440.         case BUF_FLUSH: outbuffer[outbufpos]= '\0';
  441.                         mws(outbuffer);
  442.                         outbufpos=0;
  443.                         break;
  444.     }
  445. }
  446.   
  447. GLOBAL void ws(register char *s)
  448. /* write string */
  449. {
  450.     if(o_buf_flag)
  451.     {
  452.         while(*s)
  453.         {
  454.             outbuffer[outbufpos++]= *s++;
  455.             if(outbufpos > OBLEN-3)
  456.             {
  457.                 outbuffer[outbufpos]= '\0';
  458.                 mws(outbuffer);
  459.                 outbufpos=0;
  460.             }
  461.         }
  462.     }
  463.     else 
  464.     mws(s);
  465. }
  466. #endif
  467.  
  468. #if CPM
  469. GLOBAL void ws(register char *s)
  470. /* write string */
  471. { register int i; register char *p;
  472.   for(i=0, p=s; *p; p++) i++;
  473.   if(write(FOUTPTR(outputfile),s,i) !=i && !UserAbort)
  474.           IO_Error(FNAME(outputfile),NOTWRITE);
  475. }
  476. #endif
  477.  
  478. /****************** I N I T I A L I S A T I O N *****************/
  479.  
  480. LOCAL initcounter=0;
  481.  
  482. LOCAL TERM node(register ATOM A)
  483. { register TERM T;
  484.   T=heapterms(1);
  485.   name(T)=A; son(T)=nil_term; return T;
  486. }
  487.  
  488. GLOBAL void InitIO(void)
  489. { 
  490.   int i;
  491.   tempterm = nil_term;
  492.   if(initcounter++) { ISEOF(inputfile)=false; return; } 
  493.      FNAME(0)=node(STDIN_0); ISEOF(0)=false; ISTTY(0)=isatty(0);
  494.      CANREAD(0)=!(CANWRITE(0)=false); ISINPUT(0)=true;
  495.      FCHARPOS(0)=FBUFLENGTH(0)=0;FLINENO(0)=1;
  496.      FLOGNAME(0)=STDIN_0;
  497.  
  498.      FNAME(1)=node(STDOUT_0); ISEOF(1)=false; ISTTY(1)=isatty(1);
  499.      CANREAD(1)=!(CANWRITE(1)=true); ISINPUT(1)=false;
  500.      FLOGNAME(1)=STDOUT_0;
  501.  
  502.      FNAME(2)=node(STDERR_0); ISEOF(2)=false; ISTTY(2)=isatty(2);
  503.      CANREAD(2)=!(CANWRITE(2)=true); ISINPUT(2)=false;
  504.      FLOGNAME(2)=STDERR_0;
  505.  
  506.      FNAME(3)=node(STDTRACE_0); ISEOF(3)=false; ISTTY(3)=isatty(0);
  507.      CANREAD(3)=!(CANWRITE(3)=true); ISINPUT(3)=false;
  508.      FLOGNAME(3)=STDTRACE_0;
  509.  
  510. #if HELP
  511.      FNAME(4)=node(STDHELP_0); ISEOF(4)=false; ISTTY(4)=isatty(0);
  512.      CANREAD(4)=!(CANWRITE(4)=true); ISINPUT(4)=false;
  513.      FLOGNAME(4)=HELP_0;
  514. #endif
  515. #if !HELP
  516.      FNAME(4)=nil_term;
  517. #endif
  518. #if HELP 
  519.      for(i=0;i<5;i++)
  520. #endif
  521. #if !HELP
  522.      for(i=0;i<4;i++)
  523. #endif
  524.      {
  525.          FTYPE(i)=NORMFT;
  526.          FOUTPTR(i)=FINPTR(i)=i;
  527. #if WINDOWS
  528.          if(xWINDOW_ON)
  529.          {
  530.              FTYPE(i)=WINDOWFT;
  531.              FWINPTR(i)=STDWIN;
  532.              CANREAD(i)=CANWRITE(i)=true;
  533.          }
  534. #endif
  535.      }
  536.      FINPTR(4)=FINPTR(3)=0;
  537.      FOUTPTR(4)=FOUTPTR(3)=1;
  538.      inputfile=STDIN;outputfile=STDOUT;
  539.      for(i=5;i<MAXFILES;i++) FNAME(i)=nil_term;
  540.     tempterm=heapterms(1); son(tempterm)=nil_term;
  541.     /* md: used in phy_name */
  542. }
  543.  
  544. GLOBAL char CH, LASTCH;
  545. GLOBAL int  ERRPOS;
  546.  
  547. /* also used in read.c */
  548. GLOBAL boolean unget=false;
  549. GLOBAL int FirstCharPos=0;
  550.  
  551. GLOBAL void fillbuffer(void)
  552. {
  553.  FirstCharPos=CHARPOS=ERRPOS=LINELENGTH=0;
  554. #if WINDOWS
  555.   if(FTYPE(inputfile)==NORMFT)
  556. #endif
  557.   {
  558.     if((LINELENGTH=read(FINPTR(inputfile),LINEBUF,BUFLENGTH-1)) < 0)
  559.         IO_Error((FNAME(inputfile)),NOTREAD);
  560.     if(LINELENGTH==0) ISEOF(inputfile)=true; else ISEOF(inputfile)=false;
  561.   }
  562. #if WINDOWS
  563.   else if(xWINDOW_ON) /* FTYPE(inputfile)==WINDOWFT */
  564.   {
  565.     if((LINELENGTH=w_gets(FWINPTR(inputfile),LINEBUF,BUFLENGTH-1)) < 0)
  566.         IO_Error((FNAME(inputfile)),NOTREAD);
  567.     if(LINELENGTH==0) ISEOF(inputfile)=true; else ISEOF(inputfile)=false;
  568.   }
  569. #endif
  570.  LINEBUF[LINELENGTH]=0;
  571. }
  572.  
  573. GLOBAL boolean FILEENDED(void)
  574. {
  575. if(!unget && CHARPOS >=LINELENGTH && !ISTTY(inputfile))
  576.  fillbuffer();
  577. return (!unget && ISEOF(inputfile) && (CHARPOS >=LINELENGTH));
  578. }
  579.  
  580. /* Get the next character of the current input file in 'ch'. */
  581. /* inline-code in READIN */
  582. GLOBAL void GETCHAR(void)
  583. { 
  584.   if(unget){unget=false; return;}
  585.   LASTCH=CH;
  586.   if(FILEENDED()){CH= '\n'; return; }
  587.   if( CHARPOS >=LINELENGTH ){
  588.      /* no char's in the buffer */
  589.      fillbuffer();
  590.      }
  591.   CH=LINEBUF[CHARPOS++] ;if(ECHOFLAG)wc(CH);
  592.   if(CH== '\n') {FirstCharPos=CHARPOS ; ERRPOS=0; LINENUMBER++;}
  593. }
  594.  
  595. GLOBAL boolean LINEENDED(void)
  596. { if(CHARPOS >=LINELENGTH && !ISTTY(inputfile))
  597.  fillbuffer();
  598.   return (FILEENDED() || LINEBUF[CHARPOS]== '\n');
  599. }
  600.  
  601. GLOBAL void REGET(void)
  602. { unget=true;
  603. }
  604.  
  605. LOCAL struct { int ERRNR; string ERRMSG; } ERRTAB[]=
  606. { { ABORTE         ,  "execution aborted"  },
  607.   { ARGE           ,  "unsuitable argument(s) to system predicates"  },
  608.   { ATOMSPACEE     ,  "out of atom space"  },
  609.   { BADARITYE      ,  "arity of functor out of range"  },
  610.   { BADCDDE        ,  "probably malformed ',..'"  },
  611.   { BADCHARE       ,  "character value out of range"  },
  612.   { BADDOTE        ,  "closing bracket missing"  },
  613.   { BADEXPE        ,  "malformed expression"  },
  614.   { BADKETE        ,  "unmatched closing bracket"  },
  615.   { BADTYPE        ,  "bad numerical argument type "  },
  616.   { CALLE          ,  "unsuitable arguments to 'call'"  },
  617.   { COMMENTE       ,  "unterminated comment"  },
  618.   { DEPTHE         ,  "nesting too deep  probably cyclic term"  },
  619.   { DIV0E          ,  "division or mod by zero"  },
  620.   { EOFE           ,  "unexpected end of file"  },
  621.   { FRAMESPACEE    ,  "out of frame space"  },
  622.   { IOERROR        ,  "I/O error"  },
  623.   { LOCALSPACEE    ,  "out of local stack space"  },
  624.   { NEEDOPE        ,  "infix or postfix operator expected"  },
  625.   { NEEDQUOTEE     ,  "closing quote expected"  },
  626.   { NEEDRANDE      ,  "operand or prefix operator expected"  },
  627.   { NUMBERSYNE     ,  "bad number syntax"  },
  628.   { NVARSE         ,  "out of variable table space"  },
  629.   { PRECE          ,  "operator has unsuitable precedence"  },
  630.   { PROGFAILE      ,  "goal failed during program input"  },
  631.   { READNESTE      ,  "nesting too deep in input"  },
  632.   { READSTACKE     ,  "read stack overflow"  },
  633.   { STDFUNCARGE    ,  "standard function called with wrong argument"  },
  634.   { SYSPROCE       ,  "accessing or modifying system procedures"  },
  635.   { TRAILSPACEE    ,  "out of trail space"  },
  636.   { UNDEFFUNCE     ,  "undefined function in expression"  },
  637.   { VARSPACEE      ,  "out of variable name space"  },
  638.   { WIERDCHE       ,  "illegal character in input"  },
  639.   { aSTRINGSPACEE  ,  "out of string space"  },
  640.   { FPEXCEPTE      ,  "floating point exception" },
  641.   { CANTCR         ,  "can't create file" },   
  642.   { CANTOP         ,  "can't open file" },      
  643.   { NOTOPEN        ,  "file is not open" },      
  644.   { ISTTYE         ,  "file is a tty" },          
  645.   { TOMANY         ,  "to many files" },           
  646.   { CUROUT         ,  "file is current outputfile" },
  647.   { CURINP       ,  "file is current inputfile" },
  648.   { ONLOUT         ,  "file is only open for output" },
  649.   { ONLINP         ,  "file is only open for input" }, 
  650.   { CODESPACEE     ,  "out of code space" },
  651.   { LABELSPACEE    ,  "out of label space" },
  652.   { UNDEFLABEL     ,  "undefined label" },
  653.   { 0              ,  "" }
  654. };
  655.  
  656. GLOBAL string ERRORMSG(int N)
  657. { register int I;
  658.     for(I=0; ERRTAB[I].ERRNR; I++)
  659.       if(ERRTAB[I].ERRNR==N) break;
  660.   return ERRTAB[I].ERRMSG;
  661. }
  662.  
  663. GLOBAL void ABORT(int N)
  664. { 
  665.   static abort_counter=0;
  666.   if(N !=NOERROR)
  667.   { 
  668.     if(abort_counter++  >  2 ||
  669.        (outputfile=OpenFile(phy_name(STDERR_0),write_mode)) < 0)
  670.       outputfile=STDERR;
  671.     ws("\n");
  672.     if(non_nil_term(CALLX)) ABORT_WRITE(CALLX);
  673.     ws("\nERROR ");wi(N);
  674.     ws(": "); ws(ERRORMSG(N)); ws(".\n"); 
  675. #if WINDOWS
  676.     if(xWINDOW_ON && FTYPE(outputfile)==WINDOWFT)
  677.     {
  678.           ws("\npress any key to continue");
  679.           t_rc(); /* lese ein zeichen vom terminal ohne echo */
  680.           CloseFile(outputfile);
  681.     }
  682. #endif
  683.   }
  684.   ERRORFLAG=0; EVENT=SPYTRACE;
  685.   if(TOPENV) KILLSTACKS(TOPENV);
  686.   abort_counter=0;
  687.   LONG_JMP(101);
  688. }
  689.  
  690.  
  691. GLOBAL void ARGERROR(void)
  692. { ERROR(ARGE); }
  693.  
  694. GLOBAL void ERROR(int N)
  695. {
  696.     ERRORFLAG=N;
  697.     EVENT=true;
  698.     ERRORJMP();
  699. }
  700.  
  701. GLOBAL void FileError(int error)
  702. {
  703.     if(!FERRORFLAG) return;
  704.     ERROR(error);
  705. }
  706.  
  707. /* Output an error message and recover if possible */
  708.  
  709. GLOBAL void SYNERROR(int N)
  710. { int  I;
  711.   if(FLOGNAME(inputfile) !=STDIN_0)
  712.   {  if((outputfile=OpenFile(phy_name(STDERR_0),write_mode)) < 0)
  713.         outputfile=STDERR;
  714.      ws("\nSYNTAXERROR  file: ");
  715.      WRITEOUT(phy_name(FLOGNAME(inputfile)),false);
  716.      ws("  line: ");
  717.      wi(LINENUMBER+1);
  718.      ws("  position: ");
  719.      wi(CHARPOS-FirstCharPos);
  720.      ws("\n");
  721.      if(!ECHOFLAG) { 
  722.         for(I=FirstCharPos;LINEBUF[I]!='\n' && I < LINELENGTH; I++)
  723.             wc(LINEBUF[I]);
  724.         ws("\n");
  725.         }
  726. #ifdef ARCHY
  727.      if( SYNCLFLAG ) CloseFile( inputfile );
  728. #endif
  729.  
  730.   }
  731.   for(I=FirstCharPos; I<ERRPOS-1; ++I)
  732.     if(LINEBUF[I]=='\t') ws("\t"); else ws(" ");
  733.   ws("^"); 
  734.  
  735.   if(inputfile==STDIN || FTYPE(inputfile)==WINDOWFT) 
  736.       CHARPOS=LINELENGTH;
  737.   CALLX=nil_term;
  738.   ERROR(N);
  739. }
  740.  
  741. GLOBAL void SYSTEMERROR(string m)
  742. { out_2("\n\n[System Error in: "); out_2(m); out_2("]\n"); 
  743.   LONG_JMP(999);
  744. } 
  745.  
  746.  
  747.  
  748. #define abs(l)           (((l) < 0L) ? -(l) : (l))
  749.  
  750. LOCAL file f;
  751. LOCAL TERM filename;
  752. LOCAL ATOM matom;
  753. LOCAL TERM seestack[MAXFILES];
  754. LOCAL int seesptr = 0;
  755.  
  756. GLOBAL boolean DOSEE(void)
  757. {
  758.     CHECKATOM(A0);
  759.     matom=name(A0);
  760.     if(matom==USER_0)matom=STDIN_0;
  761.     filename=phy_name(matom);
  762.     f=OpenFile(filename,read_mode);
  763.     switch(f)
  764.     {
  765.          case NOFILE:  FileError(CANTOP); return false;
  766.          case ERRFILE: FileError(TOMANY); return false;
  767.          default:      
  768.                if(f==outputfile && FTYPE(f)==NORMFT)
  769.                    { FileError(CUROUT); return false; } 
  770.                if(!CANREAD(f))
  771.                    { FileError(ONLOUT); return false; }
  772.                if( inputfile != f ) {
  773.                   seestack[seesptr] = FNAME(inputfile);
  774.                   if( ++seesptr > MAXFILES )
  775.                     SYSTEMERROR( "SEE.1: Too many nested see's" );
  776.                   inputfile=f;
  777.                 }
  778.               if(!ISINPUT(inputfile))
  779.                {
  780.                  ISINPUT(inputfile)=true;
  781.                  CHARPOS=LINELENGTH=0;
  782.                }
  783.     }
  784.     FLOGNAME(inputfile)=copyatom(matom);
  785.     return true;
  786. }
  787.  
  788. GLOBAL boolean DOSEEN(void)
  789. {
  790.      if( seesptr <= 0 ) {
  791.         seesptr = 0;     
  792.         return true;
  793.      }
  794.      CloseFile( inputfile );
  795.      inputfile = OpenFile( seestack[--seesptr], read_mode );
  796.      ISEOF(inputfile) = false;
  797.      return true;
  798. }
  799.  
  800. GLOBAL boolean DOOPEN(void)
  801. {
  802.     CHECKATOM(A0);
  803.     matom=name(A0);
  804.     if(matom==USER_0) return true; /* user is open ! */
  805.     filename=phy_name(matom);
  806.     switch(f=OpenFile(filename,read_write))
  807.     {
  808.          case NOFILE:  FileError(CANTOP);return false;
  809.          case ERRFILE: FileError(TOMANY);return false;
  810.     }
  811.     FLOGNAME(f)=copyatom(matom);
  812.     return true;
  813. }
  814.  
  815. GLOBAL boolean DOCLOSE(void)
  816. {
  817.     CHECKATOM(A0);
  818.     matom=name(A0);
  819.     if(matom==USER_0) return true; /* ! */
  820.     filename=phy_name(matom);
  821.     if((f=OpenFile(filename,look_mode))==NOFILE)
  822.     {
  823.          FileError(NOTOPEN);return false;
  824.     }
  825.     CloseFile(f);
  826.     if(inputfile==f) 
  827.         if((inputfile=OpenFile(phy_name(STDIN_0),read_mode)) < 0)
  828.         inputfile=STDIN;
  829.     if(outputfile==f)
  830.         if((outputfile=OpenFile(phy_name(STDOUT_0),write_mode)) < 0)
  831.         outputfile=STDOUT;
  832.     return true;
  833. }
  834.  
  835.  
  836. GLOBAL boolean DOTELL(void)
  837. {
  838.     CHECKATOM(A0);
  839.     matom=name(A0);
  840.     if(matom==USER_0)matom=STDOUT_0;
  841.     filename=phy_name(matom);
  842.     switch(f=OpenFile(filename,write_mode))
  843.     {
  844.          case NOFILE:  FileError(CANTCR); return false;
  845.          case ERRFILE: FileError(TOMANY); return false;
  846.          default:      
  847.                if(f==inputfile && FTYPE(f)==NORMFT)
  848.                    { FileError(CURINP); return false; }
  849.                if(!CANWRITE(f))
  850.                    { FileError(ONLINP); return false; }
  851.                outputfile=f;
  852.               if(ISINPUT(outputfile) && FTYPE(f)==NORMFT)
  853.               {
  854.                  ISINPUT(outputfile)=false;
  855.                  (void)lseek(outputfile,
  856.                        (long)(FCHARPOS(outputfile)-
  857.                              FBUFLENGTH(outputfile)),1);
  858.              }
  859.     }
  860.     FLOGNAME(outputfile)=copyatom(matom);
  861.     return true;
  862. }
  863.  
  864.  
  865. #if !CPM
  866. GLOBAL boolean DOSEEK(void)
  867. {
  868.     long l;
  869.     boolean res;
  870.  
  871.     CHECKATOM(A0);
  872.     if(name(A0)==USER_0) ARGERROR();
  873.     matom=name(A0);
  874.     filename=phy_name(matom);
  875.     if((f=OpenFile(filename,look_mode))<0)
  876.         { FileError(NOTOPEN); return false; }
  877.     if((f<3)||ISTTY(f)||FTYPE(f) !=NORMFT)
  878.         { FileError(ISTTYE); return false; }
  879.     switch(name(A1))
  880.     {
  881.          case END_0:
  882.                  l=lseek(f,0L,2);
  883.                  res= (l >=0L);
  884.                  FBUFLENGTH(f)=FCHARPOS(f)=0;
  885.                  break;
  886.          case INTT: l=(long)ival(A1); goto contseek;
  887. #if LONGARITH
  888.          case LONGT: l=  longval(A1);
  889. #endif
  890.       contseek:  res= (lseek(f,abs(l),(l >=0) ? 0 : 2) >=0L);
  891.                  FBUFLENGTH(f)=FCHARPOS(f)=0;
  892.                  break;
  893.          case UNBOUNDT:
  894.                  l=lseek(f,(long)0,1);
  895.                  l=l-(long)
  896.                      (ISINPUT(f) ? (FBUFLENGTH(f)-FCHARPOS(f)):0);
  897. #if LONGARITH
  898.                  return LONGRES(A1,l);
  899. #endif
  900. #if ! LONGARITH
  901.                  return INTRES(A1,(int)l);
  902. #endif
  903.          default: ARGERROR();
  904.     }
  905.     return res;
  906. }
  907. #endif
  908.  
  909. LOCAL TERM oldfilename;
  910. GLOBAL void setinfile(void)
  911. {
  912.     oldfilename=FNAME(inputfile);
  913.     if((inputfile=OpenFile(phy_name(STDIN_0),read_mode)) < 0)
  914.     {
  915.         inputfile=STDIN ; /*  ?????? */
  916.     }
  917. }
  918.  
  919. GLOBAL void getinfile(void)
  920. {
  921.     if((inputfile=OpenFile(oldfilename,read_mode)) < 0)
  922.         SYSTEMERROR("getinfile.1");
  923. }
  924.  
  925. GLOBAL void setoutfile(void)
  926. {
  927.     oldfilename=FNAME(outputfile);
  928.     if((outputfile=OpenFile(phy_name(STDOUT_0),write_mode)) < 0)
  929.     {
  930.         outputfile=STDOUT ; /*  ?????? */
  931.     }
  932. }
  933. GLOBAL void getoutfile(void)
  934. {
  935.     if((outputfile=OpenFile(oldfilename,write_mode)) < 0)
  936.         SYSTEMERROR("getoutfile.1");
  937. }
  938.  
  939. GLOBAL boolean DOGET0(void)
  940. { 
  941.     register int ch;
  942.     if(FILEENDED())ch= -1;
  943.     else { GETCHAR(); ch=CH; }
  944.     return INTRES(A0,ch);
  945. }
  946.  
  947. GLOBAL boolean DOGET(void)
  948. { 
  949.     register int ch;
  950.   nextch:
  951.     if(FILEENDED()) ch= -1; 
  952.     else 
  953.     { GETCHAR();
  954.       if(CH<=' ' || CH>=127) goto nextch;
  955.       ch= (int)CH;
  956.     }
  957.     return INTRES(A0,ch);
  958. }
  959.  
  960. GLOBAL void DOSKIP(void)
  961. {
  962.     register int n;
  963.     n=(INTVALUE(A0) & 255);
  964.   nextch:
  965.     if(FILEENDED()) return;
  966.     GETCHAR();
  967.     if(CH!=n) goto nextch;
  968. }
  969.  
  970. GLOBAL boolean DOASK(void)
  971. {
  972.     register int ch;
  973.   nextch:
  974.     if(FILEENDED()) return true;
  975.     GETCHAR(); 
  976.     if(CH==0) goto nextch;
  977.     ch=CH;
  978.     while((CH!=10) && !FILEENDED())
  979.         GETCHAR();
  980.     if(name(A0)==UNBOUNDT) return INTRES(A0,ch);
  981.     return INTVALUE(A0)==ch;
  982. }
  983.  
  984. GLOBAL void DOTAB(void)
  985. {  register int n;
  986.    n=INTVALUE(A0);
  987. #if !CPM
  988.    out_buffer(BUF_ON);
  989. #endif
  990.    while(n-->0) ws(" ");
  991. #if !CPM
  992.    out_buffer(BUF_OFF);
  993. #endif
  994. }
  995.  
  996. GLOBAL void DOPUT(void)
  997. {
  998. #if !CPM
  999.   out_buffer(BUF_ON);
  1000. #endif
  1001.     while(name(A0)==CONS_2)
  1002.       { wc((char)(INTVALUE(arg1(A0)) & 255)); A0=arg2(A0); }
  1003.     if(name(A0)!=NIL_0)
  1004.          wc((char)((INTVALUE(A0))&255));
  1005. #if !CPM
  1006.   out_buffer(BUF_OFF);
  1007. #endif
  1008. }
  1009.  
  1010.  
  1011. GLOBAL boolean DOFASSIGN(void)
  1012. {
  1013.     register CLAUSE CL,CC;
  1014.     TERM F;
  1015.  
  1016.     if(! ground(A0,MAXDEPTH)) ARGERROR();
  1017.     if(!ground(A1,MAXDEPTH)) 
  1018.     {
  1019.         for(CL=clause(FNAME_2);non_nil_clause(CL);CL=nextcl(CL))
  1020.         {
  1021.             if(var_sizes(CL) !=0) SYSTEMERROR("assign");
  1022.             if(UNI(A0,arg2(head(CL)))) 
  1023.                return UNI(A1,arg1(head(CL)));
  1024.         }
  1025.         return false;
  1026.     }
  1027.  
  1028.     for(CL=CC=clause(FNAME_2);non_nil_clause(CL);CC=CL,CL=nextcl(CL))
  1029.     {
  1030.         if(var_sizes(CL) !=0) SYSTEMERROR("assign");
  1031.         if(UNI(A0,arg2(head(CL))))
  1032.         { if(CL==clause(FNAME_2)) clause(FNAME_2)=nextcl(CL);
  1033.           else nextcl(CC)=nextcl(CL);
  1034.           destroycl(CL);
  1035.           break;
  1036.         }
  1037.     }
  1038.  
  1039.     if(UNI(A0,A1)) return true;
  1040.     F=mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term);
  1041.     (void)UNI(F,A1);(void)UNI(br(F),A0);
  1042.     CL=heapterms(3);
  1043.     name(head(CL))=FNAME_2; son(head(CL))=SKELETON(FNAME_2,F);
  1044.     name(body(CL))=nil_atom; nextcl(CL)=clause(FNAME_2); setnvars(CL,0); 
  1045.     clause(FNAME_2)=CL;
  1046.     return true;
  1047. }
  1048.  
  1049. GLOBAL void DOCLS(void)
  1050. { 
  1051. #if WINDOWS
  1052.   if(xWINDOW_ON && FTYPE(outputfile)==WINDOWFT) 
  1053.     w_cls(FWINPTR(outputfile));
  1054.   else 
  1055. #endif
  1056.     ws(s_cls());
  1057. }
  1058.  
  1059. GLOBAL void DOGOTOXY(void)
  1060. { register int S,Z;
  1061.   extern TERM A0,A1;
  1062.   extern int INTVALUE();
  1063.   S=INTVALUE(A0);Z=INTVALUE(A1);
  1064. #if WINDOWS
  1065.   if(xWINDOW_ON && FTYPE(outputfile)==WINDOWFT) 
  1066.     w_gotoxy(FWINPTR(outputfile),S,Z);
  1067.   else 
  1068. #endif
  1069.     ws(s_gotoxy(S,Z));
  1070. }
  1071.     
  1072.  
  1073.